home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 5 / Skunkware 5.iso / lib / perl5 / Cwd.pm < prev    next >
Encoding:
Perl POD Document  |  1995-07-03  |  3.0 KB  |  162 lines
  1. package Cwd;
  2. require 5.000;
  3. require Exporter;
  4.  
  5. @ISA = qw(Exporter);
  6. @EXPORT = qw(getcwd fastcwd);
  7. @EXPORT_OK = qw(chdir);
  8.  
  9.  
  10. # By Brandon S. Allbery
  11. #
  12. # Usage: $cwd = getcwd();
  13.  
  14. sub getcwd
  15. {
  16.     my($dotdots, $cwd, @pst, @cst, $dir, @tst);
  17.  
  18.     unless (@cst = stat('.'))
  19.     {
  20.     warn "stat(.): $!";
  21.     return '';
  22.     }
  23.     $cwd = '';
  24.     do
  25.     {
  26.     $dotdots .= '/' if $dotdots;
  27.     $dotdots .= '..';
  28.     @pst = @cst;
  29.     unless (opendir(PARENT, $dotdots))
  30.     {
  31.         warn "opendir($dotdots): $!";
  32.         return '';
  33.     }
  34.     unless (@cst = stat($dotdots))
  35.     {
  36.         warn "stat($dotdots): $!";
  37.         closedir(PARENT);
  38.         return '';
  39.     }
  40.     if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
  41.     {
  42.         $dir = '';
  43.     }
  44.     else
  45.     {
  46.         do
  47.         {
  48.         unless ($dir = readdir(PARENT))
  49.         {
  50.             warn "readdir($dotdots): $!";
  51.             closedir(PARENT);
  52.             return '';
  53.         }
  54.         unless (@tst = lstat("$dotdots/$dir"))
  55.         {
  56.             warn "lstat($dotdots/$dir): $!";
  57.             closedir(PARENT);
  58.             return '';
  59.         }
  60.         }
  61.         while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
  62.            $tst[1] != $pst[1]);
  63.     }
  64.     $cwd = "$dir/$cwd";
  65.     closedir(PARENT);
  66.     } while ($dir);
  67.     chop($cwd);
  68.     $cwd;
  69. }
  70.  
  71.  
  72.  
  73. # By John Bazik
  74. #
  75. # Usage: $cwd = &fastcwd;
  76. #
  77. # This is a faster version of getcwd.  It's also more dangerous because
  78. # you might chdir out of a directory that you can't chdir back into.
  79.  
  80. sub fastcwd {
  81.     my($odev, $oino, $cdev, $cino, $tdev, $tino);
  82.     my(@path, $path);
  83.     local(*DIR);
  84.  
  85.     ($cdev, $cino) = stat('.');
  86.     for (;;) {
  87.     ($odev, $oino) = ($cdev, $cino);
  88.     chdir('..');
  89.     ($cdev, $cino) = stat('.');
  90.     last if $odev == $cdev && $oino == $cino;
  91.     opendir(DIR, '.');
  92.     for (;;) {
  93.         $_ = readdir(DIR);
  94.         next if $_ eq '.';
  95.         next if $_ eq '..';
  96.  
  97.         last unless $_;
  98.         ($tdev, $tino) = lstat($_);
  99.         last unless $tdev != $odev || $tino != $oino;
  100.     }
  101.     closedir(DIR);
  102.     unshift(@path, $_);
  103.     }
  104.     chdir($path = '/' . join('/', @path));
  105.     $path;
  106. }
  107.  
  108.  
  109. # keeps track of current working directory in PWD environment var
  110. #
  111. # $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $
  112. #
  113. # $Log:    pwd.pl,v $
  114. #
  115. # Usage:
  116. #    use Cwd 'chdir';
  117. #    chdir $newdir;
  118.  
  119. $chdir_init = 0;
  120.  
  121. sub chdir_init{
  122.     if ($ENV{'PWD'}) {
  123.     my($dd,$di) = stat('.');
  124.     my($pd,$pi) = stat($ENV{'PWD'});
  125.     if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
  126.         chop($ENV{'PWD'} = `pwd`);
  127.     }
  128.     }
  129.     else {
  130.     chop($ENV{'PWD'} = `pwd`);
  131.     }
  132.     if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
  133.     my($pd,$pi) = stat($2);
  134.     my($dd,$di) = stat($1);
  135.     if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
  136.         $ENV{'PWD'}="$2$3";
  137.     }
  138.     }
  139.     $chdir_init = 1;
  140. }
  141.  
  142. sub chdir {
  143.     my($newdir) = shift;
  144.     chdir_init() unless $chdir_init;
  145.     return 0 unless (CORE::chdir $newdir);
  146.     if ($newdir =~ m#^/#) {
  147.     $ENV{'PWD'} = $newdir;
  148.     }else{
  149.     my(@curdir) = split(m#/#,$ENV{'PWD'});
  150.     @curdir = '' unless @curdir;
  151.     foreach $component (split(m#/#, $newdir)) {
  152.         next if $component eq '.';
  153.         pop(@curdir),next if $component eq '..';
  154.         push(@curdir,$component);
  155.     }
  156.     $ENV{'PWD'} = join('/',@curdir) || '/';
  157.     }
  158. }
  159.  
  160. 1;
  161.  
  162.